home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / pascal / xlibpas2.zip / XLARC.PAS < prev    next >
Pascal/Delphi Source File  |  1994-06-11  |  4KB  |  159 lines
  1. {$G+,N-,E-}
  2.  
  3. program XLArc;
  4.  
  5. uses
  6.     XLA2, XMisc2, Dos;
  7.  
  8. var
  9.     f : file;
  10.     p1, p2, p3 : string;
  11.     S : SearchRec;
  12.     n : NameStr;
  13.     d,d1 : DirStr;
  14.     e : ExtStr;
  15.     tmp : boolean;
  16.     i : integer;
  17.     size : longint;
  18.     compsize, origsize : longint;
  19.     mode : word;
  20.     filename : string;
  21.  
  22. procedure ReadFile( var data; s : word; var actual : longint ); far;
  23. var
  24.     amountread : word;
  25. begin
  26.     blockread( f, data, s, amountread );
  27.     actual := amountread;
  28. end;
  29.  
  30. procedure WriteFile( var data; blocksize : word ); far;
  31. begin
  32.     blockwrite( f, data, blocksize );
  33. end;
  34.  
  35. procedure Usage;
  36. begin
  37.     writeln('XLArc v2.04 - XLib archiving utility - FREEWARE');
  38. {$IFDEF DPMI}
  39.     write('DPMI Version - ');
  40. {$ENDIF}
  41.     writeln('(C) 1994 Tristan Tarrant');
  42.     writeln('Usage :');
  43.     writeln('XLArc l|x|a archive.XLA filenames');
  44.     writeln('  Switches ');
  45.     writeln('    l - list files in archive');
  46.     writeln('    x - extract files from archive');
  47.     writeln('    a0 - add files to archive with no compression');
  48.     writeln('    a1 - add files to archive with LZS compression');
  49.     halt(0);
  50. end;
  51.  
  52. begin
  53.     XLAOutProc := WriteFile;
  54.     XLAInProc := ReadFile;
  55.     if ParamCount < 2 then Usage;
  56.     p1 := ParamStr(1);
  57.     p2 := ParamStr(2);
  58.     xstrupcase( p1 );
  59.     xstrupcase( p2 );
  60.     FSplit( p2, d, n, e );
  61.     if e = '' then e := '.XLA';
  62.     p2 := d+n+e;
  63.     if p1 = 'L' then
  64.     begin
  65.         if not XOpenArchive( p2 ) then
  66.         begin
  67.             writeln('Error opening file : ',p2 );
  68.             halt(1);
  69.         end;
  70.         writeln('Contents of archive ',p2 );
  71.         XPrintDir;
  72.         XCloseArchive;
  73.     end else
  74.     if (p1[1] = 'A') and ((p1[2]>='0') or (p1[2]<='1')) then
  75.     begin
  76.         if ParamCount < 3 then Usage;
  77.         if xexists( p2 ) then
  78.             tmp := XUpdateArchive( p2 )
  79.         else
  80.             tmp := XCreateArchive( p2 );
  81.         if not tmp then
  82.         begin
  83.             writeln('Cannot create file : ',p2 );
  84.             halt(1);
  85.         end;
  86.         for i := 3 to ParamCount do
  87.         begin
  88.             p3 := ParamStr( i );
  89.             FSplit( p3, d1, n, e );
  90.             FindFirst( p3, Archive, S );
  91.             while DosError = 0 do
  92.             begin
  93.                 if not xexists( d1+S.Name ) then
  94.                 begin
  95.                     writeln('Cannot open file : ',d1+S.Name );
  96.                     halt(1);
  97.                 end;
  98.                 FSplit( S.Name, d, n, e );
  99.                 if e <> '.XLA'  then
  100.                 begin
  101.                     if XLAGetFileInfo(S.Name, origsize, compsize, mode) then
  102.                         writeln('Skipping file ',S.Name,' : already in archive')
  103.                     else
  104.                     begin
  105.                         assign( f, d1+S.Name );
  106.                         reset( f, 1 );
  107.                         writeln('Adding ', S.Name,'...' );
  108.                         case p1[2] of
  109.                             '0' : XLAPut( S.Name, None );
  110.                             '1' : XLAPut( S.Name, LZS );
  111.                         end;
  112.                         close( f );
  113.                     end;
  114.                 end;
  115.                 FindNext(S);
  116.             end;
  117.         end;
  118.         XEndArchive;
  119.         writeln('Done.');
  120.     end else
  121.     if p1 = 'X' then
  122.     begin
  123.         if ParamCount <3 then Usage;
  124.         p3 := ParamStr( 3 );
  125.         xstrupcase( p3 );
  126.         if not XOpenArchive( p2 ) then
  127.         begin
  128.             writeln('Could not open file ',p2 );
  129.             halt(1);
  130.         end;
  131.         tmp := XLAFindFirst( p3, filename );
  132.         if not tmp then
  133.         begin
  134.             Writeln('No matches for ',p3,' in archive ',p2 );
  135.             halt(1);
  136.         end;
  137.         while tmp do
  138.         begin
  139.             if not XLAGetFileInfo(filename, origsize, compsize, mode) then
  140.             begin
  141.                 writeln('File ',filename,' does not exist in archive ',p2 );
  142.                 halt(1);
  143.             end;
  144.             writeln('Extracting ',filename,'...');
  145.             assign( f, filename);
  146.             rewrite( f, 1 );
  147.             if not XLAGet(filename) then
  148.             begin
  149.                 writeln('Could not extract ',filename );
  150.                 halt(1);
  151.             end;
  152.             close( f );
  153.             tmp := XLAFindNext( filename );
  154.         end;
  155.         XCloseArchive;
  156.         writeln('Done.');
  157.     end else Usage;
  158. end.
  159.